;;###########################################################################
;; dataobj6.lsp
;; Copyright (c) 1991-99 by Forrest W. Young
;; This file contains code for array data
;; FUNCTIN2.LSP HAS ARRAY FUNCTIONS
;;###########################################################################

(defun border-matrix-with-sums (x)
"Args: X
Borders matrix X with its row, col and grand sums"
  (let* ((row-sums (mapcar #'sum (row-list x)))
         (col-sums (mapcar #'sum (column-list x)))
         (sum-sums (sum row-sums))
         (col-sums+sum-sums (combine col-sums sum-sums))
         (sizes (array-dimensions x))
         (nr (first sizes))
         (nc (second sizes)))
    (if (= nr 1)
        (if (= nc 1)
            x
            (bind-columns x row-sums))
        (if (= nc 1)
            (bind-rows x col-sums)
            (bind-rows (bind-columns x row-sums) col-sums+sum-sums)))))

(defmeth mv-data-object-proto :active-data-array ()
"Args: none
Returns the data array for the active data. Re-computes all array information and updates all array slots when necessary."
 (send self :make-active-array)
  (send self :data-array))

(defmeth mv-data-object-proto :active-freq-array ()
"Args: none
Returns the frequency array for the active data. Re-computes all array information and updates all array slots when necessary."
  (send self :make-active-array)
  (send self :freq-array))

(defmeth mv-data-object-proto :active-array-labels ()
"Args: none
Returns the array labels for the active data. Re-computes all array information and updates all array slots when necessary."
 (send self :make-active-array)
 (send self :array-labels))

(defmeth mv-data-object-proto :active-array-variables ()
"Args: none
Returns the array variables for the active data. Re-computes all array information and updates all array slots when necessary."
 (send self :make-active-array)
 (send self :array-variables))

(defmeth mv-data-object-proto :make-active-array ()
  "Args: none
When necessary, computes all array information and updates all array slots using currently active data."
  (when (and (send self :array) (send self :array-needs-updating))
        (if (equal (send self :data-type) "freq")
            (send self :make-array-from-2way-freq-table)
            (send self :make-array :stuff-slots t :freq (send self :freq)))
        (send self :array-needs-updating nil))
  t)

(defmeth mv-data-object-proto :array-dimensions ()
  (if (send self :array) (array-dimensions (send self :active-data-array)) nil))

(defmeth mv-data-object-proto :extract-array (&optional array &rest args)
"Args: &optional ARRAY & rest INDICES
Extracts a sub-array from ARRAY, which defaults to the freq-array of self. INDICES specifies the sub-array to be extracted. The number of INDICES must equal the number of ways of the array. Each index may be either an integer, a list of integers, or an !, where ! is a wildcard value meaning all levels of the index. Specifying an integer index reduces the number of levels of the returned array for each integer index. A list or integers or ! are not reducing operations. The indices for a way must in the range of number of levels of the way."
  (apply #'extract-array (if array array (send self :freq-array)) args))

(defmeth mv-data-object-proto :print-array-to-window 
                 (array w &key way-labels level-labels)
  (let* ((nways (length (array-dimensions array))) (str-list)
         (array-list) (index-list) (indices 0) (index) (result) (go? t)
         (table-number 0)
         )
    (when (> nways 4)
          (error-message "The Maximum number of Ways is 4. Please select fewer categorical variables."))
    (when 
     (> nways 3)
     (dolist (i (iseq 0 (- nways 2)))
             (dolist (j (iseq (1+ i) (- nways 1)))
                     (setf result (first (array-list array (list i j) t)))
                     (setf indices (+ indices (length result)))))
     (setf non-nil-indices
           (length (remove 'nil (make-array (list (prod (send $ :array-dimensions)))
                                            :displaced-to (send $ :data-array)))))
  ;   (when 
  ;    (> non-nil-indices 10)
  ;    (setf go? (yes-or-no-dialog 
  ;               (format nil "There are ~d Tables with~%at least one cell which has~%a non-zero frequency. ~2%Do you want to see these~%~a tables? ~2%Alternatively, you can select~%fewer categorical variables~%to see fewer tables)." non-nil-indices non-nil-indices))))
     )
    (when go?
          (display-string 
           (format nil "~%_________________________________~%") w)
          (display-string (format nil "~%Frequency Tables") w)
          (dolist (i (iseq 0 (- nways 2)))
                  (dolist (j (iseq (1+ i) (- nways 1)))
                          (setf result (array-list array (list i j) t))
                          (setf array-list (first result))
                          (setf index-list (second result))
                          (when way-labels
                                (display-string (format nil "~2%Table~a of ~a by ~a for "
                                                        (if (> nways 2) "s" "")
                                                        (select way-labels i)
                                                        (select way-labels j)) w))
                          (when (and way-labels (> nways 2))
                                (setf str-list way-labels)
                                (mapcar #'(lambda (str)
                                            (setf str-list ;
                                                  (remove str str-list
                                                          :test #'equal)))
                                        (list (select way-labels i)
                                              (select way-labels j)))
                    
                                (when (= nways 3) 
                                      (display-string (format nil 
                                        "each level of ~a~%" 
                                            (first str-list)) w))
                                (when (> nways 3)
                                      (display-string (format nil 
                                        "~%every combination of levels of ") w)
                                      (dotimes (i (- nways 2))
                                               (display-string
                                                (format nil "~a " 
                                                     (select str-list i)) w)))
                                (display-string (format nil "~%") w))
                          
                          (dotimes (k (length array-list)) 
                                   (when (> (sum (select array-list k)) 0)
                                         (setf table-number (1+ table-number))
                                         (display-string 
                                          (format nil "~%Table ~d: " table-number) w)
                                         (display-string
                                          (format nil "~a by ~a for "
                                                  (select way-labels i)
                                                  (select way-labels j)) w)
                                         (setf indices (select index-list k))
                                         (dotimes (L (length indices))
                                                  (when (>= L K)
                                                        (setf index (select indices L))
                                                        (when (and (not (equal index "!")) 
                                                                   level-labels way-labels)
                                                              (display-string 
                                                               (format nil "~a [level ~a]  "
                                                                       (select way-labels L)
                                                                       (select 
                                                                        (select level-labels L) 
                                                                        index)) w))))

                                         (display-string (format nil "~%") w)
                                   
                                         (if (and level-labels way-labels)
                                             (print-matrix-to-window 
                                              (select array-list k) w
                                              :row-heading (select way-labels i)
                                              :column-heading (select way-labels j)
                                              :row-labels (select level-labels i)
                                              :column-labels (select level-labels j))
                                             (print-matrix-to-window
                                              (select array-list k) w))
                                         (display-string (format nil "~%") w)
                                         ))
                          )))))

(defmeth mv-data-object-proto :check-array-dimensions (cat-var-names)
  (let* ((var)(dim)(dims))
    (mapcar #'(lambda (varname)
                (setf var (send self :variable varname))
                (setf dim (length (remove-duplicates var :test #'equal)))
                (setf dims (append dims (list dim)))
                )
            cat-var-names)
    dims))

 (defmeth mv-data-object-proto :make-array 
  (&key stuff-slots freq on-error all-types-in-data-array
        (category-variables (send self :active-variables '(category)))
        (numeric-variables  (send self :active-variables '(numeric))))
"Args: &KEY CATEGORY-VARIABLES NUMERIC-VARIABLES STUFF-SLOTS FREQ ON-ERROR ALL-TYPES-IN-DATA-ARRAY
Uses the N active category variables (by default, all the active category variables) and any additional numeric variables (by default, all the active numeric variables) to form an N-way frequency array, and an N-way data array (which are identical when the data object has no numeric variables). Each way has levels equal to the categories of each corresponding active category variable. When FREQ is T the numeric variables are assumed to contain frequency information. When ON-ERROR is T returns a list of information about the array after user has cancelled table making due to too large a table. Otherwise exits to top-level. When ALL-TYPES-IN-DATA-ARRAY is T all variables are placed in data-array, otherwise only numeric variables.
   Returns a four-element list of the frequency array, data array, array-labels and array-variables. The first two elements are identical when FREQ is T.
   When STUFF-SLOTS is T, updates slots as follows: Sets :ARRAY-NEEDS-UPDATING to NIL. Places frequency array in :FREQ-ARRAY slot (the array cells contain the frequency of each cell). If there are numeric variables in the data, then the slot :DATA-ARRAY receives an n-way array of observed data, each cell containing a list of the numeric values that are in the data for that combination of category variable levels (same as :freq-array slot when the data are frequencies). Places a list-of-lists of array-level labels in :ARRAY-LABELS, and a list of variable names in :ARRAY-VARIABLES. The :ARRAY slot is marked as T." 
   
   (when category-variables
         (let* ((array-dims (send self :check-array-dimensions category-variables))
                (result) (freq-mat)(freq-list) (error-return)
                )
           (cond
             ((< (prod array-dims) 300001)
              (setf result t))
             ((> (prod array-dims) 300000)
              (setf result nil)
              (message-dialog (format nil "Too many cells  (~d) to create data array.~%Some analyses will not be possible." (prod array-dims))))
             ((> 3000 (prod array-dims) 300000)
              (setf result (yes-or-no-dialog (format nil "Shall I create the ~a-way table for these data?~%It would have ~a levels, and ~d cells."(length array-dims) array-dims (prod array-dims))))))
           (when (not result) 
                 (when (not on-error) (top-level))
                 (setf error-return array-dims))
           (when all-types-in-data-array
                 (setf numeric-variables (send self :active-variables '(all))))
           (unless error-return
                   (setf result (send self :convert-category-variables-to-freq
                                      category-variables numeric-variables))
                   (when (and freq numeric-variables);when data are freq but not categorical
                         (setf freq-list (mapcar #'(lambda (val) (if val val 0))
                                                 (combine (third result))))
                         (if (> (length (combine (third result))) 
                                (prod (array-dimensions (first result))))
                             (setf freq-list 
                                   (mapcar #'sum 
                                           (send self :convert-array-to-cell-list 
                                                 (third result) (first result))))
                             (setf freq-list (mapcar #'(lambda (val) (if val val 0))
                                                     (combine (third result)))))
                         (setf freq-mat 
                               (make-array (array-dimensions (third result)) 
                                           :initial-contents freq-list)))
                   (when stuff-slots
                         (send self :freq-array 
                       (if (and freq numeric-variables) freq-mat (first result)))
                         (send self :array-labels (second result))
                         (send self :array-variables category-variables)
                         (send self :data-array 
                               (if numeric-variables (third result) (first result)))
                         (send self :array t)
                         (send self :array-needs-updating nil))
                   (list (if (and freq numeric-variables) freq-mat (first result))
                         (if numeric-variables (third result) (first result))
                         (second result) category-variables))
           (if error-return error-return result))))
   
   (defmeth mv-data-object-proto :make-array-from-2way-freq-table ()
"Args: NONE
Creates frequency array information for two-way frequency table data."

  (send self :freq-array (send self :active-data-matrix '(numeric)))
  (send self :data-array (send self :freq-array))
  (send self :array-variables (send self :freq-way-names))
  (send self :array-labels (list (send self :active-labels)
                                 (send self :active-variables '(numeric))))
  (send self :array t))
       

(defmeth mv-data-object-proto :convert-category-to-freq ()
"Args: None
Converts the N current active category variables into N-way frequency array. Returns a list whose first element is the N-way array, and whose second element is a list of category labels."
  (send self :convert-category-variables-to-freq 
        (send self :active-variables '(category))))

(defmeth mv-data-object-proto :convert-category-variables-to-freq 
  (cat-var-list &optional num-var-list)
"Args: CAT-VAR-LIST &OPTIONAL NUM-VAR-LIST
The arguments must each be a list of variable name strings.
Converts the CAT-VAR-LIST category variables into an N-way frequency array. Returns a list whose first element is the N-way frequency array, and whose second element is a list of category labels. If NUM-VAR-LIST is specified the values of its variables are also returned in two forms: 1) as lists which are elements of NUM-ARRAY, an N-way array, with lists placed according to categories; 2) as a list whose elements are nil or a list of elements of response matrix in array-major order."
  (let* ((cat-data-mat 
          (apply #'bind-columns 
                 (mapcar #'(lambda (var) 
                             (send self :active-variable '(category) var))
                         cat-var-list)))
         (num-data-mat
          (if num-var-list
              (apply #'bind-columns 
                     (mapcar #'(lambda (var) 
                                 (send self :active-variable '(numeric) var))
                             num-var-list))
              nil))
         (ncatvars (second (array-dimensions cat-data-mat)))
         (nobs (first (array-dimensions cat-data-mat)))
         (ncats (repeat nil ncatvars))
         (cats (mapcar 
                #'(lambda (i)
                    (coerce (remove-duplicates (col cat-data-mat i) :test #'equal) 
                            'list))
                (iseq ncatvars)))
         (freq-array) (num-array) (element) (sizes) (cat-resp-list)
         )
    (when num-var-list
          (setf num-vars-values 
                (mapcar #'(lambda (num-var)
                            (send self :variable num-var))
                        num-var-list)))
    (dotimes (i ncatvars)
             (setf (select ncats i) 
                   (length (remove-duplicates (col cat-data-mat i) :test #'equal))))
    (setf freq-array (make-array ncats :initial-element 0))
    (when num-var-list (setf num-array (make-array ncats :initial-element nil)))
    (dotimes (i nobs)
             (setf element
                   (mapcar 
                    #'(lambda (j)
                        (position (aref cat-data-mat i j) (select cats j) :test #'equal))
                    (iseq ncatvars)))
             (when num-var-list
                   (setf (apply #'aref num-array element)
                         (append (apply #'aref num-array element) 
                                 (list (coerce (row num-data-mat i) 'list)))))
             (setf (apply #'aref freq-array element) 
                   (1+ (apply #'aref freq-array element))))
    (when num-var-list
          (setf cat-resp-list 
                (send self :convert-array-to-cell-list 
                      num-array freq-array)))
    (if num-var-list
          (list freq-array cats num-array cat-resp-list)
          (list freq-array cats))))

(defmeth mv-data-object-proto :convert-array-to-cell-list (array cell-freq-array)
  (let ((cell-freq-list (combine cell-freq-array))
        (element-list (combine array))
        (cell-list) (LL 0) (UL)
        )
    (setf testa (make-array (prod (array-dimensions array)) :displaced-to array))
    (setf test (mapcar #'(lambda (list)
                           (cond 
                             ((listp list)
                              (mapcar #'(lambda (sublist)
                                          (cond 
                                            ((listp sublist) (first sublist))
                                            ((null sublist) (list nil))
                                            (t sublist))
                                          )
                                      list))
                             ((null list) (list nil))
                             (t list)))
                       (coerce testa 'list)))
    test)
  )
             

(defmeth mv-data-object-proto :convert-array2freqclass ()
"Args: none
Converts the contents of the frequency array to a frequency classification data matrix. Result is a matrix whose first column contains frequencies and whose remaining n columns contain category name strings."
  (let* ((f-array (send self :active-freq-array))
         (sizes (array-dimensions f-array))
         (levels (send self :array-labels))
         (nr (first sizes))
         (nc (second sizes))
         (restlevels (rest (rest levels)))
         (result (array-list f-array (list 0 1) t))
         (matrix-list (first result))
         (array-indices (second result))
         (class-matrix)
         (temp-matrix) (temp-matrix2))
    (dotimes (i (length matrix-list))
             (setf temp-matrix 
                   (freq-matrix-to-freq-class 
                    (select matrix-list i)
                    (list (first levels) (second levels))))
             (when restlevels
                   (setf restindices (rest (rest (select array-indices i))))
                   (setf levels-now (mapcar #'(lambda (list i) (select list i))
                                            restlevels restindices))
                   (setf temp-matrix2 (matrix (list (* nr nc) (length levels-now))
                                              (repeat levels-now (* nr nc))))
                   (setf temp-matrix (bind-columns temp-matrix temp-matrix2)))
             (setf class-matrix (if class-matrix
                                    (bind-rows class-matrix temp-matrix)
                                    temp-matrix))
             )
    class-matrix))

            
(defmeth mv-data-object-proto :convert-freq-to-category-data-object ()
  (let* ((results (send self :convert-freq-to-category :info-window t))
         )
    (data (strcat "Cat-" (send self :name))
          :created (send *desktop* :selected-icon)
          :data (combine (first results))
          :variables (third results)
          :labels (second results)
          :types (repeat "Category" (length (third results))))))

(defmeth mv-data-object-proto :convert-freq-to-category (&key info-window)
  (when (not (send self :freq)) (fatal-message "These data are not Frequency Data."))
  (let* ((freq (send self :active-data-matrix '(numeric)))
         (tot-freq (sum freq))
         (running-freq 0)
         (row-names (send self :active-labels))
         (col-names (send self :active-variables '(numeric)))
         (cat-names (send self :active-variables '(category)))
         (cat-data-in (send self :active-data-matrix '(category)))
         (cat-data-out)
         (obs-labels)
         (var-names (send self :freq-way-names))
         (nrows (length row-names))
         (ncols (length col-names))
         (freq-cell)
         (w (if info-window
                (info-window  "00 Percent Converted" 
                              :title "Please Wait" :size '(200 30))
                nil))
         )
    (if w (send w :fit-window-to-text))
    (when (not (first var-names)) 
          (setf var-names (list "Rows" "Columns")))
    (when cat-names (setf var-names (combine var-names cat-names)))
    (dotimes (i nrows)
             (setf row-name (select row-names i))
             (dotimes (j ncols)
                      (setf freq-cell (floor (aref freq i j)))
                      (setf col-name (select col-names j))
                      (setf running-freq (+ running-freq freq-cell))
                      (dotimes (k freq-cell)
                               (setf cat-data-out 
                                     (add-element-to-list 
                                      cat-data-out (list row-name col-name)))
                               (setf this-obs-label (strcat row-name "*" col-name))
                               (when cat-names 
                                     (strcat this-obs-label
                                             (mapcar #'(lambda (L)
                                                         (strcat this-obs-label
                                                                 "*"
                                                                 (select cat-names L)))
                                                     (iseq ncats)))
                                     (setf cat-data-out (add-element-to-list
                                                     cat-data-out (row cat-data-in i))))
                               (setf obs-labels (add-element-to-list obs-labels 
                                                                     this-obs-label)))
                      (when w
                            (send w :flush-window)
                            (send w :paste-string
                                  (format nil "~d Percent Converted" 
                                          (truncate (* 100 (/ running-freq tot-freq)))))
                            (send w :show-window)
                            (send w :redraw))
                      ))
    
    (when w (send w :close))
    (list cat-data-out obs-labels var-names)))
                         

(defmeth mv-data-object-proto :convert-freqclass2cat ()
  (let* ((cat-mat (send self :active-data-matrix '(category)))
         (frq-var (column-list (send self :active-data-matrix '(numeric))))
         (result)
         )
    (when (and frq-var (> (length frq-var) 1))
          (setf frq-var (send self :variable "frequency"))
          (if (not frq-var) 
              (setf frq-var (send self :variable "freq"))
              (fatal-message "Cant find frequency variable."))
          )
    (setf frq-var (coerce (first frq-var) 'list))
    (setf result (mapcar #'(lambda (list ntimes)
                             (matrix (list ntimes (length list))
                                     (repeat list ntimes)))
                         (row-list cat-mat) frq-var))
    (apply #'bind-rows result)))

(defmeth mv-data-object-proto :convert-freqclass2cat-dob (name)
  (let* ((cat-vars (send self :active-variables '(category)))
         (cat-mat (send self :convert-freqclass2cat))
         (data (combine cat-mat))
         (labels (send self :make-labels-from-cat-matrix cat-mat))
         (new-name 
          (if name name
              (send self :get-new-data-name name
                    (strcat "Cat-" (send self :name)))))
         )
    (data new-name
          :freq t
          :array t
          :created (send *workmap* :selected-icon)
          :labels labels
          :variables cat-vars
          :types (repeat "Category" (length cat-vars))
          :data data)))


;SET RECORDING INFO PV April-2003

(defmeth mv-data-object-proto :record-linking-info ()

  ;this part sets a graph in a slot that is used as bridge for linking the data object
  ;to the plots related with this data object
  (let (
        (graph (scatterplot (normal-rand (send self :nobs)) (normal-rand (send self :nobs)) :show nil))
        (data-object self)
               )
    
    (send self :add-slot 'linked-graph)
    
    (defmeth self :linked-graph (&optional (linked-graph nil set))
      "Sets or retrieves the graph that is used as bridge for point properties."
      (if set (setf (slot-value 'linked-graph) linked-graph))
      (slot-value 'linked-graph))
    
   

    (send data-object :linked-plots (remove 'nil (combine graph (send data-object :linked-plots))))

    ;(send graph :after-new-plot nil nil nil (list 10 10) *active-container* t t self)

   (defmeth graph :data-object ()
      data-object)
    (defmeth graph :setup-linkage ()  
      (defmeth self :links ()
          (let* ((dob (send self :data-object))
                 (plot-list (send dob :links)))
            (setf plot-list (send dob :links))
            (if (member self plot-list) plot-list)))
        (defmeth self :linked (&optional (link nil set))
          (when set
                (let* ((dob (send self :data-object))
                       (plot-list (send dob :linked-plots)))
                  (send dob :linked-plots
                        (if link
                            (cons self plot-list)
                            (remove self plot-list))))
                (call-next-method link))
          (call-next-method)))
   
    
   ; (send graph :setup-linkage)
    (send graph :linked t)
   ; (send *obs-window* :linked t)
    (send self :linked-graph graph)

    ;follows methods for accessing the information in the graph from the data object


    (defmeth self :point-color (index &optional colors)
      (if colors (send (send self :linked-graph) :point-color index colors)
          (send (send self :linked-graph) :point-color index)))

    (defmeth self :point-symbol (index &optional symbols)
      (if symbols (send (send self :linked-graph) :point-symbol index symbols)
          (send (send self :linked-graph) :point-symbol index)))

    (defmeth self :point-state (index &optional states)
      (if states (send (send self :linked-graph) :point-state index states)
          (send (send self :linked-graph) :point-state index)))

    (defmeth self :point-selected (index &optional states)
      (if states (send (send self :linked-graph) :point-selected index states)
          (send (send self :linked-graph) :point-selected index)))

    (defmeth self :selection (&optional index)
      (if index (send (send self :linked-graph):selection index )
          (send (send self :linked-graph) :selection)))


   t ))